home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / XLisp_1.6.cpt / PP.LSP < prev    next >
Lisp/Scheme  |  1985-04-27  |  5KB  |  193 lines
  1. ;+
  2. ;               PP 1.0 : (C) Copyright 1985 by Gregory Frascadore
  3. ;
  4. ;   This software may be copied, modified, and distributed to others as long
  5. ;   as it is not sold for profit, and as long as this copyright notice is
  6. ;   retained intact. For further information contact the author at:
  7. ;               frascado%umn-cs.CSNET   (on CSNET)
  8. ;               75106,662               (on CompuServe)
  9. ;-
  10.  
  11. ;+
  12. ;                               PP 1.0
  13. ; DESCRIPTION
  14. ;   PP is a function for producing pretty-printed XLISP code. Version 1.0
  15. ;   works with XLISP 1.4 and may work with other versions of XLISP or other
  16. ;   lisp systems.
  17. ;
  18. ; UPDATE HISTORY
  19. ;   Version 1.0 - Original version, 11 April 1985 by Gregory Frascadore.
  20. ;
  21. ;-
  22.  
  23. ;+
  24. ; pp
  25. ;   This function pretty-prints an s-expression.
  26. ;
  27. ; format
  28. ;   (pp <expr> [<sink>] )
  29. ;
  30. ;       <expr>  the expression to print.
  31. ;       <sink>  optional. the sink to print to. defaults to
  32. ;                   *standard-output*
  33. ;       <maxlen> the threshold that pp uses to determine when an expr
  34. ;                   should be broken into several lines. The smaller the
  35. ;                   value, the more lines are used. Defaults to 45 which
  36. ;                   seems reasonable and works well too.
  37. ;-
  38.  
  39. (defun pp (*expr &optional *sink *maxlen)
  40.    (if (null *sink) (setq *sink *standard-output*))
  41.    (if (null *maxlen) (setq *maxlen 45))
  42.  
  43.    (let ((pp-stack* nil) (pp-istack* '(0)) (pp-currentpos* 0))
  44.  
  45.            (pp-expr *expr)
  46.            (pp-newline) t) )
  47.  
  48.  
  49. (defun pp-expr (*expr)
  50.    (cond ((consp *expr)
  51.             (pp-list *expr) )
  52.  
  53.          (t (pp-prin1 *expr)) ) )
  54.  
  55.  
  56. ;+
  57. ; pp-list
  58. ;   Pretty-print a list expression.
  59. ;       IF <the flatsize length of *expr is less than *maxlen>
  60. ;           THEN print the expression on one line,
  61. ;       ELSE
  62. ;       IF <the car of the expression is an atom>
  63. ;           THEN print the expression in the following form:
  64. ;                   "(atom <item1>
  65. ;                          <item2>
  66. ;                           ...
  67. ;                          <itemn> )"
  68. ;       ELSE
  69. ;       IF <the car of the expression is a list>
  70. ;           THEN print the expression in the following form:
  71. ;                   "(<list1>
  72. ;                     <item2>
  73. ;                       ...
  74. ;                     <itemn> )"
  75. ;
  76. ;-
  77.  
  78. (defun pp-list (*expr)
  79.    (cond ((< (flatsize *expr) *maxlen)
  80.             (pp-prin1 *expr) )
  81.  
  82.          ((atom (car *expr))
  83.             (pp-start)
  84.             (pp-prin1 (car *expr))
  85.             (pp-princ " ")
  86.             (pp-pushmargin)
  87.             (pp-rest (cdr *expr))
  88.             (pp-popmargin)
  89.             (pp-finish) )
  90.  
  91.          (t (pp-start)
  92.             (pp-pushmargin)
  93.             (pp-rest *expr)
  94.             (pp-popmargin)
  95.             (pp-finish) ) ) )
  96.  
  97. ;+
  98. ; pp-rest
  99. ;   pp-expr each element of a list and do a pp-newline after every call to
  100. ;   pp-expr except the last.
  101. ;-
  102.  
  103. (defun pp-rest (*rest)
  104.    (do* ((item* *rest (cdr item*)))
  105.         ((null item*))
  106.             (pp-expr (car item*))
  107.             (if (not (null (cdr item*))) (pp-newline)) ) )
  108.  
  109. ;+
  110. ; pp-newline
  111. ;   Print out a newline character and indent to the current margin setting
  112. ;   which is maintained at the top of the pp-istack. Note that is the
  113. ;   current top of the pp-stack* is a ")" we push a " " so that we will know
  114. ;   to print a space before closing any parenthesis which were started on a
  115. ;   different line from the one they are being closed on.
  116. ;-
  117.  
  118. (defun pp-newline ()
  119.    (if (eql ")" (pp-top pp-stack*)) (pp-push " " pp-stack*))
  120.  
  121.    (terpri *sink)
  122.    (spaces (pp-top pp-istack*) *sink)
  123.    (setq pp-currentpos* (pp-top pp-istack*)) )
  124.  
  125. ;+
  126. ; pp-finish
  127. ;   Print out the closing ")". If the top of the pp-stack* has a " " on it,
  128. ;   then print out the space, then the ")" , and then pop both off the stack.
  129. ;-
  130.  
  131. (defun pp-finish ()
  132.    (cond ((eql ")" (pp-top pp-stack*))
  133.             (pp-princ ")") )
  134.  
  135.          (t
  136.             (pp-princ " )")
  137.             (pp-pop pp-stack*) ) )
  138.  
  139.    (pp-pop pp-stack*) )
  140.  
  141.  
  142. ;+
  143. ; pp-start
  144. ;   Start printing a list. ie print the "(" and push a ")" on the pp-stack*
  145. ;   so that pp-finish knows to print a ")" when closing an list.
  146. ;-
  147.  
  148. (defun pp-start ()
  149.    (pp-princ "(")
  150.    (pp-push ")" pp-stack*) )
  151.  
  152. ;+
  153. ; pp-princ
  154. ;   Prints out an expr without any quotes and updates the pp-currentpos*
  155. ;   pointer so that we know where on the line the cursor is at.
  156. ;-
  157.  
  158. (defun pp-princ (*expr)
  159.     (setq pp-currentpos* (+ pp-currentpos* (flatc *expr)))
  160.     (princ *expr *sink) )
  161.  
  162. ;+
  163. ; pp-prin1
  164. ;   Does the same thing as pp-prin1, except that the expr is printed with
  165. ;   quotes if needed. Hence pp-prin1 uses flatsize to calc expr length instead
  166. ;   of flatc.
  167. ;-
  168.  
  169. (defun pp-prin1 (*expr)
  170.     (setq pp-currentpos* (+ pp-currentpos* (flatsize *expr)))
  171.     (prin1 *expr *sink) )
  172.  
  173. (defmacro pp-push (*item *stack)
  174.    `(setq ,*stack (cons ,*item ,*stack)) )
  175.  
  176.  
  177. (defmacro pp-pop (*stack)
  178.    `(let ((top* (car ,*stack)))
  179.  
  180.         (setq ,*stack (cdr ,*stack))
  181.         top*) )
  182.  
  183.  
  184. (defun pp-top (*stack) (car *stack))
  185.  
  186.  
  187. (defun pp-pushmargin ()
  188.    (pp-push pp-currentpos* pp-istack*) )
  189.  
  190.  
  191. (defun pp-popmargin ()
  192.    (pp-pop pp-istack*) )
  193.